home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
551-575
/
disk_556
/
scheme2c
/
scheme-src.lzh
/
scrt
/
scrt2.sc
< prev
next >
Wrap
Text File
|
1991-10-11
|
18KB
|
617 lines
;;; SCHEME->C Runtime Library
;* Copyright 1989 Digital Equipment Corporation
;* All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions. Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software. Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software. Correspondence should be provided to Digital at:
;*
;* Director of Licensing
;* Western Research Laboratory
;* Digital Equipment Corporation
;* 100 Hamilton Avenue
;* Palo Alto, California 94301
;*
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.
;*
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.
(module scrt2
(top-level
SYMBOL? SYMBOL->STRING TOP-LEVEL-VALUE SET-TOP-LEVEL-VALUE!
GETPROP PUTPROP
FIXED? FLOAT? FLOAT->FIXED FIXED->FLOAT
NUMBER? COMPLEX? REAL? RATIONAL? INTEGER? ZERO? POSITIVE? NEGATIVE?
ODD? EVEN? EXACT? INEXACT? = < > <= >= MAX MIN + * - / ABS QUOTIENT
REMAINDER MODULO GCD LCM FLOOR CEILING TRUNCATE ROUND
EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT
EXACT->INEXACT INEXACT->EXACT
NUMBER->STRING STRING->NUMBER))
;;; 6.4 Symbols.
(define (SYMBOL? x) (symbol? x))
(define (SYMBOL->STRING x) (symbol->string x))
(define (TOP-LEVEL-VALUE symbol)
(if (not (symbol? symbol))
(error 'TOP-LEVEL-VALUE "Argument is not a SYMBOL: ~s" symbol))
((lap (symbol) (SYMBOL_VALUE symbol)) symbol))
(define (SET-TOP-LEVEL-VALUE! symbol value)
(if (not (symbol? symbol))
(error 'SET-TOP-LEVEL-VALUE! "Argument is not a SYMBOL: ~s" symbol))
((lap (symbol value) (SETGENTL (SYMBOL_VALUE symbol) value)) symbol value))
(define (GETPROP symbol key)
(if (not (symbol? symbol))
(error 'GETPROP "Argument is not a SYMBOL: ~s" symbol))
(let loop ((pl ((lap (symbol) (SYMBOL_PROPERTYLIST symbol)) symbol)))
(cond ((null? pl) #f)
((eq? (car pl) key) (cadr pl))
(else (loop (cddr pl))))))
(define (PUTPROP symbol key value)
(if (not (symbol? symbol))
(error 'PUTPROP "Argument is not a SYMBOL: ~s" symbol))
(let loop ((pl ((lap (symbol) (SYMBOL_PROPERTYLIST symbol)) symbol))
(prev '()))
(cond ((null? pl)
(if (not (eq? value #f))
(if prev
(set-cdr! prev (list key value))
((lap (symbol newpl)
(SETGEN (SYMBOL_PROPERTYLIST symbol) newpl))
symbol (list key value)))))
((eq? (car pl) key)
(if (eq? value #f)
(if prev
(set-cdr! prev (cddr pl))
((lap (symbol newpl)
(SETGEN (SYMBOL_PROPERTYLIST symbol) newpl))
symbol (cddr pl)))
(set-car! (cdr pl) value)))
(else (loop (cddr pl) (cdr pl)))))
value)
;;; 6.5 Numbers.
;;; Arithmetic overflow traps possibly enabled here.
(define-external (MATHTRAPS) "sc" "mathtraps")
(mathtraps)
(define (FIXED? x) (fixed? x))
(define (FLOAT? x) (float? x))
(define (FLOAT->FIXED x) (float->fixed x))
(define (FIXED->FLOAT x) (fixed->float x))
(define (NUMBER? x) (or (fixed? x) (float? x)))
(define (COMPLEX? x) (or (fixed? x) (float? x)))
(define (REAL? x) (or (fixed? x) (float? x)))
(define (RATIONAL? x) (fixed? x))
(define (INTEGER? x) (fixed? x))
(define (ZERO? x) (= x 0))
(define (POSITIVE? x) (> x 0))
(define (NEGATIVE? x) (< x 0))
(define (ODD? x) (odd? x))
(define (EVEN? x) (even? x))
(define (EXACT? x) (exact? x))
(define (INEXACT? x) (inexact? x))
(define (=-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (BOOLEAN (EQ (INT x) (INT y)))) x y))
((float? y)
((lap (x y) (BOOLEAN (EQ (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '= "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y) (BOOLEAN (EQ (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '= "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y) (BOOLEAN (EQ (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '= "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (= x y . z)
(define (=-LIST x z)
(cond ((null? z) #t)
((= x (car z)) (=-list (car z) (cdr z)))
(else #f)))
(and (= x y) (=-list y z)))
(define (<-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (BOOLEAN (LT (INT x) (INT y)))) x y))
((float? y)
((lap (x y) (BOOLEAN (LT (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '< "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y) (BOOLEAN (LT (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '< "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y) (BOOLEAN (LT (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '< "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (< x y . z)
(define (<-LIST x z)
(cond ((null? z) #t)
((< x (car z)) (<-list (car z) (cdr z)))
(else #f)))
(and (< x y) (<-list y z)))
(define (>-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (BOOLEAN (GT (INT x) (INT y)))) x y))
((float? y)
((lap (x y) (BOOLEAN (GT (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '> "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y) (BOOLEAN (GT (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '> "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y) (BOOLEAN (GT (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '> "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (> x y . z)
(define (>-LIST x z)
(cond ((null? z) #t)
((> x (car z)) (>-list (car z) (cdr z)))
(else #f)))
(and (> x y) (>-list y z)))
(define (<=-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (BOOLEAN (LTE (INT x) (INT y)))) x y))
((float? y)
((lap (x y) (BOOLEAN (LTE (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '<= "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y) (BOOLEAN (LTE (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '<= "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y) (BOOLEAN (LTE (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '<= "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (<= x y . z)
(define (<=-LIST x z)
(cond ((null? z) #t)
((<= x (car z)) (<=-list (car z) (cdr z)))
(else #f)))
(and (<= x y) (<=-list y z)))
(define (>=-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (BOOLEAN (GTE (INT x) (INT y)))) x y))
((float? y)
((lap (x y) (BOOLEAN (GTE (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '>= "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y) (BOOLEAN (GTE (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '>= "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y) (BOOLEAN (GTE (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '>= "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (>= x y . z)
(define (>=-LIST x z)
(cond ((null? z) #t)
((>= x (car z)) (>=-list (car z) (cdr z)))
(else #f)))
(and (>= x y) (>=-list y z)))
(define (MAX-TWO x y) (if (> x y) x y))
(define (MAX x . y)
(let loop ((x x) (y y))
(if y
(loop (if (> x (car y)) x (car y)) (cdr y))
x)))
(define (MIN-TWO x y) (if (< x y) x y))
(define (MIN x . y)
(let loop ((x x) (y y))
(if y
(loop (if (< x (car y)) x (car y)) (cdr y))
x)))
(define (+-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (_TSCP (IPLUS (INT x) (INT y)))) x y))
((float? y)
((lap (x y) (FLTV_FLT (PLUS (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '+ "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y) (FLTV_FLT (PLUS (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '+ "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y) (FLTV_FLT (PLUS (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '+ "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (+ . x)
(let loop ((sum 0) (x x))
(if x
(loop (+ sum (car x)) (cdr x))
sum)))
(define (*-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (_TSCP (ITIMES (FIXED_C x) (INT y)))) x y))
((float? y)
((lap (x y)
(FLTV_FLT (TIMES (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '* "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y)
(FLTV_FLT (TIMES (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '* "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y) (FLTV_FLT (TIMES (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '* "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (* . x)
(let loop ((product 1) (x x))
(if x
(loop (* product (car x)) (cdr x))
product)))
(define (--TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
((lap (x y) (_TSCP (IDIFFERENCE (INT x) (INT y)))) x y))
((float? y)
((lap (x y)
(FLTV_FLT (DIFFERENCE (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '- "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y)
(FLTV_FLT (DIFFERENCE (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '- "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y)
(FLTV_FLT (DIFFERENCE (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '- "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (- x . y)
(if y
(let loop ((result (- x (car y))) (args (cdr y)))
(if args
(loop (- result (car args)) (cdr args))
result))
(- 0 x)))
(define (/-TWO x y)
(cond ((fixed? x)
(cond ((fixed? y)
(if (eq? ((lap (x y) (_TSCP (REMAINDER (INT x) (INT y))))
x y)
0)
((lap (x y) (C_FIXED (QUOTIENT (INT x) (INT y)))) x y)
((lap (x y) (FLTV_FLT (QUOTIENT (FIX_FLTV x)
(FIX_FLTV y))))
x y)))
((float? y)
((lap (x y)
(FLTV_FLT (QUOTIENT (FIX_FLTV x) (FLOAT_VALUE y))))
x y))
(else (error '/ "Argument not a NUMBER: ~s" y))))
((fixed? y)
(cond ((float? x)
((lap (x y)
(FLTV_FLT (QUOTIENT (FLOAT_VALUE x) (FIX_FLTV y))))
x y))
(else (error '/ "Argument not a NUMBER: ~s" x))))
((and (float? x) (float? y))
((lap (x y)
(FLTV_FLT (QUOTIENT (FLOAT_VALUE x) (FLOAT_VALUE y))))
x y))
(else (error '/ "Argument(s) not a NUMBER: ~s ~s" x y))))
(define (/ x . y)
(if y
(let loop ((result (/ x (car y))) (z (cdr y)))
(if z
(loop (/ result (car z)) (cdr z))
result))
(/ 1 x)))
(define (ABS x) (if (negative? x) (- 0 x) x))
(define (QUOTIENT x y)
(if (two-fixeds? x y)
((lap (x y) (C_FIXED (QUOTIENT (INT x) (INT y)))) x y)
(truncate (/ x y))))
(define (REMAINDER x y)
(if (two-fixeds? x y)
((lap (x y) (_TSCP (REMAINDER (INT x) (INT y)))) x y)
(round (- x (* y (quotient x y))))))
(define (MODULO x y)
(let ((r (remainder x y)))
(if (zero? r)
r
(if (positive? y)
(if (positive? r) r (+ y r))
(if (negative? r) r (+ y r))))))
(define (GCD . x)
(define (GCD2 m n)
(let ((r (remainder m n)))
(if (= r 0) n (gcd2 n r))))
(case (length x)
((0) 0)
((1) (abs (car x)))
(else (let loop ((result (gcd2 (abs (car x)) (abs (cadr x))))
(left (cddr x)))
(if left
(loop (gcd2 result (abs (car left))) (cdr left))
result)))))
(define (LCM . x)
(define (LCM2 m n)
(let ((m (abs m)) (n (abs n)))
(cond ((= m n) m)
((= (remainder m n) 0) m)
((= (remainder n m) 0) n)
(else (* (/ m (gcd m n)) n)))))
(case (length x)
((0) 1)
((1) (abs (car x)))
(else (let loop ((result (lcm2 (car x) (cadr x))) (left (cddr x)))
(if left
(loop (lcm2 result (car left)) (cdr left))
result)))))
(define-c-external (c-floor double) double "floor")
(define (FLOOR x) (if (fixed? x) x (c-floor x)))
(define-c-external (c-ceiling double) double "ceil")
(define (CEILING x) (if (fixed? x) x (c-ceiling x)))
(define-c-external (c-exp double) double "exp")
(define (TRUNCATE x) (if (< x 0) (ceiling x) (floor x)))
(define (ROUND x) (if (fixed? x) x (floor (+ x .5))))
(define (EXP x) (c-exp x))
(define-c-external (c-log double) double "log")
(define (LOG x) (c-log x))
(define-c-external (c-sin double) double "sin")
(define (SIN x) (c-sin x))
(define-c-external (c-cos double) double "cos")
(define (COS x) (c-cos x))
(define-c-external (c-tan double) double "tan")
(define (TAN x) (c-tan x))
(define-c-external (c-asin double) double "asin")
(define (ASIN x) (c-asin x))
(define-c-external (c-acos double) double "acos")
(define (ACOS x) (c-acos x))
(define-c-external (c-atan double) double "atan")
(define-c-external (c-atan2 double double) double "atan2")
(define (ATAN x . y) (if y (c-atan2 x (car y)) (c-atan x)))
(define-c-external (c-sqrt double) double "sqrt")
(define (SQRT x)
(if (negative? x)
(error 'SQRT "Argument must be a non-negative NUMBER: ~s" x))
(let ((iresult (c-sqrt x)))
(if (fixed? x)
(let ((eresult (float->fixed (round iresult))))
(if (eq? (* eresult eresult) x)
eresult
iresult))
iresult)))
(define-c-external (c-pow double double) double "pow")
(define (EXPT x y)
(if (and (= x 0.0) (= y 0.0))
1.0
(let ((iresult (c-pow x y)))
(if (and (fixed? x) (fixed? y) (<= (abs iresult) #x1fffffff))
(float->fixed (round iresult))
iresult))))
(define-c-external (c-sprintf-1d pointer pointer double) pointer "sprintf")
(define (EXACT->INEXACT x)
(cond ((fixed? x) (fixed->float x))
((float? x) x)
(else (error 'EXACT->INEXACT "Argument is not a NUMBER: ~s" x))))
(define (INEXACT->EXACT x)
(cond ((fixed? x) x)
((float? x) (float->fixed x))
(else (error 'INEXACT->EXACT "Argument is not a NUMBER: ~s" x))))
(define (NUMBER->STRING number . form)
(if (not (number? number))
(error 'NUMBER->STRING "Argument is not a NUMBER: ~s" number))
(set! form (if form (car form) 10))
(cond ((equal? form '(int))
; (int) => [-]dddddddd
(let ((buffer (make-string 100))
(f (if (float? number) number (fixed->float number))))
(c-sprintf-1d buffer "%.0f" f)
(c-string->string buffer)))
((and (pair? form) (= (length form) 2) (eq? (car form) 'fix)
(fixed? (cadr form)) (>= (cadr form) 0))
; (fix n) => [-]dddddddd.
(let ((buffer (make-string 100))
(f (if (float? number) number (fixed->float number))))
(c-sprintf-1d buffer (format "%.~sf" (cadr form)) f)
(c-string->string buffer)))
((and (pair? form) (= (length form) 2) (eq? (car form) 'sci)
(fixed? (cadr form)) (>= (cadr form) 0))
; (sci n) => [-]d.ddde+dd
(let ((buffer (make-string 100))
(f (if (float? number) number (fixed->float number))))
(c-sprintf-1d buffer (format "%.~se" (- (cadr form) 1)) f)
(c-string->string buffer)))
((= form 2)
; 2 => binary integer
(integer->string number 2 "#b"))
((= form 8)
; 8 => octal integer
(integer->string number 8 "#o"))
((= form 10)
; 10 => any number
(format "~s" number))
((= form 16)
(integer->string number 16 "#x"))
(else (error 'NUMBER->STRING
"Argument is not a RADIX or FORMAT DESCRIPTOR: ~s"
form))))
(define (INTEGER->STRING number base prefix)
(if (< number 0)
(integer->string (abs number) base (string-append "-" prefix))
(string-append
prefix
(list->string
(reverse (let loop ((q (quotient number base))
(r (remainder number base)))
(let ((digit (string-ref "0123456789abcdef"
(inexact->exact r))))
(if (= 0 q)
(list digit)
(cons digit
(loop (quotient q base)
(remainder q base)))))))))))
(define (STRING->NUMBER string . radix)
(let ((radix (if radix
(case (car radix)
((2) "#b")
((8) "#o")
((10) "")
((16) "#x")
(else (error 'STRING->NUMBER
"Argument is not a RADIX: ~s"
(car radix))))
""))
(chars (string->list string)))
(let loop ((sign "") (chars chars))
(if chars
(case (car chars)
((#\- #\+) (loop (make-string 1 (car chars))
(cdr chars)))
((#\#) (try-to-read string))
(else (try-to-read (string-append sign radix
(list->string chars)))))))))
(define (TRY-TO-READ string)
(call-with-current-continuation
(lambda (return)
(let ((restore-error-handler *error-handler*))
(set! *error-handler*
(lambda x
(set! *error-handler* restore-error-handler)
(return #f)))
(let* ((port (open-input-string string))
(number (read port))
(eof (read port)))
(set! *error-handler* restore-error-handler)
(if (and (number? number) (eof-object? eof))
number
#f))))))